home *** CD-ROM | disk | FTP | other *** search
Text File | 1996-03-01 | 95.2 KB | 3,470 lines | [ TEXT/PJMM]
unit File1; {Routines used by NIH Image for implementing File Menu commands.} interface uses Types, Memory, QuickDraw, QuickDrawText, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, StandardFile, Windows, Controls, TextEdit, Files, Dialogs, TextUtils, Finder, MixedMode, Processes, globals, Utilities, Graphics, file2, Dicom, sound, Lut, Text; function CloseAWindow (WhichWindow: WindowPtr): integer; procedure DoClose; function OpenFile (fname: str255; vnum: integer): boolean; function OpenPict (fname: str255; vnum: integer; Reverting: boolean): boolean; procedure SaveFile; function DoOpen (FileName: str255; RefNum: integer): boolean; function ImportFile (FileName: str255; RefNum: integer): boolean; procedure RevertToSaved; procedure SaveAs (name: str255; RefNum: integer); procedure Export (name: str255; RefNum: integer); procedure FindWhatToPrint; procedure UpdateFileMenu; procedure SaveAsText (fname: str255; RefNum: integer); procedure SaveAll; function OpenPICS (name: str255; fRefNum: integer): boolean; procedure RescaleToEightBits; implementation var OpenAllFiles, UseExistingLUT, PICTReadErr: boolean; SaveRefNum: integer; TempStackInfo: StackInfoRec; PictSrcRect: rect; {$PUSH} {$D-} procedure LookForCluts (fname: str255; vnum: integer); var RefNum: integer; err: OSErr; ok1, ok2: boolean; begin if not UseExistingLUT then begin err := SetVol(nil, vnum); refNum := OpenResFile(fname); if RefNum <> -1 then begin ok1 := LoadCLUTResource(KlutzID); if not ok1 then ok2 := LoadCLUTResource(PixelPaintID); CloseResFile(refNum); end; end; end; function OpenImageHeader (f: integer; fname: str255; vnum: integer): boolean; var ByteCount: LongInt; err: OSErr; TempHdr: PicHeader; i, OldNExtra, p1x, p2x: integer; ok: boolean; hUnitsKind: UnitsType; begin if SizeOf(PicHeader)<>HeaderSize then begin PutError(StringOf('Internal error (size= ', SizeOf(PicHeader):1,')')); OpenImageHeader := false; exit(OpenImageHeader); end; ByteCount := HeaderSize; err := SetFPos(f, fsFromStart, info^.HeaderOffset); err := fsread(f, ByteCount, @TempHdr); if CheckIO(err) <> NoErr then begin OpenImageHeader := false; exit(OpenImageHeader); end; with info^, TempHdr do begin if PictureType <> TiffFile then begin nlines := hnlines; PixelsPerLine := hPixelsPerLine; end; if (hversion > 54) and not UseExistingLUT then begin OldNExtra := nExtraColors; nExtraColors := hnExtraColors; ExtraColors := hExtraColors; if (nExtraColors > 0) or (OldNExtra <> nExtraColors) then RedrawLUTWindow; end; if (hversion >= 42) and not UseExistingLUT then begin if hversion < 142 then begin LUTMode := hOldLUTMode; if (LutMode = OldAppleDefault) or (LutMode = OldSpectrum) then LutMode := ColorLut; end else begin LUTMode := hLUTMode; if LutMode = Pseudocolor then begin if ((hnColors > 32) and (hTable = CustomTable)) or (hTable > spectrum) then LutMode := ColorLut; end; end; case LUTMode of PseudoColor: if hversion < 142 then begin nColors := hOldnColors; for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; ColorEnd := 255 - hOldColorStart; ColorStart := ColorEnd - nColors * hColorWidth + 1; if ColorStart < 0 then ColorStart := 0; InvertPalette; FillColor1 := BlackRGB; FillColor2 := BlackRGB; ColorTable := CustomTable; UpdateLUT; end else begin {V1.42 or later} if (hTable <> CustomTable) and (hTable <= spectrum) then begin SwitchColorTables(GetColorTableItem(hTable), false); if hInvertedTable then InvertPalette; end else begin nColors := hnColors; ColorTable := CustomTable; if nColors <= 32 then for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; end; ColorStart := hColorStart; ColorEnd := hColorEnd; FillColor1 := hFill1; FillColor2 := hFill2; UpdateLUT; UpdateMap; end; {v1.42 or later} GrayScale: ResetGrayMap; ColorLut, CustomGrayscale: if PictureType <> PictFile then begin if ColorMapOffset > 0 then GetTiffColorMap(f) else LookForCluts(fname, vnum); end; otherwise end; {case} if hLutMode = CustomGrayscale then LutMode := CustomGrayscale; end;{if} if (hversion >= 65) and ((ForegroundIndex <> hForegroundIndex) or (BackgroundIndex <> hBackgroundIndex)) then begin SetForegroundColor(hForegroundIndex); SetBackgroundColor(hBackgroundIndex); end; if (hversion > 88) and (LUTMode = GrayScale) and not UseExistingLUT then begin if hversion < 138 then begin p1x := 255 - hp2x; p2x := 255 - hp1x; end else begin p1x := hp1x; p2x := hp2x end; nColors := 256; ColorStart := p1x; ColorEnd := p2x; UpdateLUT; end; if hversion > 106 then begin {xScale := hXScale;} {68k-bug} xScale := DoubleToReal(hXScale); yScale := xScale; PixelAspectRatio := 1.0; SpatiallyCalibrated := xScale <> 0.0; end; if hversion > 140 then begin PixelAspectRatio := hPixelAspectRatio; yScale := xScale / PixelAspectRatio; end; if hversion > 153 then xUnit := hXUnit else begin hUnitsKind := UnitsType(hUnitsID - 5); GetXUnits(hUnitsKind); end; if xUnit = 'pixel' then SpatiallyCalibrated := false; if ((hnCoefficients > 0) and (hfit < Uncalibrated)) or (hfit = UncalibratedOD) then begin if hfit = SpareFit1 then begin fit := uncalibrated; DrawLabels('', '', ''); end else begin fit := hfit; if hfit <> UncalibratedOD then begin nCoefficients := hnCoefficients; for i:=1 to maxCoeff do {Coefficient[i] := hCoeff[i];} {68k-bug} Coefficient[i]:=DoubleToReal(hCoeff[i]); nKnownValues := 0; end; UnitOfMeasure := hUM; if hversion >= 144 then ZeroClip := hZeroClip else ZeroClip := false; end; end else begin fit := uncalibrated; DrawLabels('', '', ''); end; BinaryPic := hBinaryPic; if hSliceEnd > 1 then begin SliceStart := hSliceStart; SliceEnd := hSliceEnd; if SliceEnd > 254 then SliceEnd := 254; end; if hNSlices > 1 then begin with TempStackInfo do begin nSlices := hNSlices; if nSlices > MaxSlices then nSlices := MaxSlices; CurrentSlice := hCurrentSlice; if (hCurrentSlice < 1) or (hCurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := hSliceSpacing; FrameInterval := hFrameInterval; StackType := VolumeStack; if hVersion >= 158 then StackType := hStackType; end; end; FileVersion := hVersion; OpenImageHeader := true end; end; function OpenHeader (f: integer; fname: str255; vnum: integer; var TiffInfo: TiffInfoRec): boolean; var ByteCount, FileSize, DirOffset, MaxImages: LongInt; hdr: packed array[1..512] of byte; err: OSErr; TempHdr: PicHeader; begin with info^ do begin if (WhatToOpen = OpenUnknown) or (WhatToOpen = OpenImported) then begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @hdr); if ((hdr[1] = 73) and (hdr[2] = 73)) or ((hdr[1] = 77) and (hdr[2] = 77)) then WhatToOpen := OpenTIFF else if WhatToOpen = OpenUnknown then WhatToOpen := OpenImage else WhatToOpen := OpenMCID; end; StackInfo := nil; with TempStackInfo do begin nSlices := 0; CurrentSlice := 1; SliceSpacing := 0.0; FrameInterval := 0.0; end; fileVersion := 0; case WhatToOpen of OpenImage: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then begin HeaderOffset := 0; PictureType := normal end else begin HeaderOffset := -1; BlockMove(@TempHdr, @hdr, 8); nlines := hdr[1] + hdr[2] * 256; PixelsPerLine := hdr[3] + hdr[4] * 256; PictureType := Imported; InvertedImage := true; end; ImageDataOffset := 512; end; OpenMCID: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); PixelsPerLine := hdr[1] + hdr[2] * 256 + 1; if PixelsPerLine > MaxLine then begin beep; PixelsPerLine := MaxLine; end; nlines := hdr[3] + hdr[4] * 256 + 1; PictureType := imported; LUTMode := grayscale; HeaderOffset := -1; ImageDataOffset := 4; end; OpenCustom: begin err := GetEof(f, FileSize); if macro then begin if (ImportCustomOffset + ImportCustomWidth * ImportCustomHeight) > FileSize then begin AbortMacro; OpenHeader := false; exit(OpenHeader) end; end; PixelsPerLine := ImportCustomWidth; nlines := ImportCustomHeight; PictureType := imported; HeaderOffset := -1; ImageDataOffset := ImportCustomOffset; if ImportCustomSlices > 1 then with TempStackInfo do begin nSlices := ImportCustomSlices; MaxImages := (FileSize - ImportCustomOffset) div (ImportCustomWidth * ImportCustomHeight); if nSlices > MaxImages then nSlices := MaxImages; if nSlices < 2 then nSlices := 0; end; end; OpenPICT2: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then HeaderOffset := 0 else HeaderOffset := -1; PictureType := PictFile; if not UseExistingLUT then LutMode := ColorLut; ImageDataOffset := 512; end; OpenTIFF: begin if not OpenTiffHeader(f, DirOffset) then begin OpenHeader := false; exit(OpenHeader) end; if not OpenTiffDirectory(f, DirOffset, TiffInfo, false) then begin OpenHeader := false; exit(OpenHeader) end; with TiffInfo do begin PictureType := TiffFile; PixelsPerLine := width; nlines := height; if BitsPerPixel = 4 then PictureType := FourBitTiff; ImageDataOffset := OffsetToData; InvertedImage := ZeroIsBlack and (PictureType <> FourBitTIFF); if resolution > 0.0 then begin case ResUnits of tNoUnits: xUnit := 'pixel'; tCentimeters: xUnit := 'cm'; tInches: xUnit := 'inch'; end; xScale := resolution; yScale := resolution; PixelAspectRatio := 1.0; if xUnit <> 'pixel' then SpatiallyCalibrated := true; end; ColorMapOffset := OffsetToColorMap; HeaderOffset := OffsetToImageHeader; end; if not UseExistingLUT then LutMode := Grayscale; end; end; {case} if HeaderOffset <> -1 then begin if not OpenImageHeader(f, fname, vnum) then begin OpenHeader := false; exit(OpenHeader) end end else if (ColorMapOffset > 0) and not UseExistingLUT then GetTiffColorMap(f); end; {with} OpenHeader := true; end; function SaveHeader (f, slines, sPixelsPerLine, vnum: integer; fname: str255; SavingSelection, SavingTIFF: boolean): OSErr; var TempHdr: PicHeader; DummyHdr: array[1..128] of LongInt; i: integer; ByteCount: LongInt; position: LongInt; err: OSErr; str: str255; UnitsKind: UnitsType; UnitsPerCM: extended; begin with TempHdr, info^ do begin for i := 1 to 128 do DummyHdr[i] := 0; BlockMove(@DummyHdr, @TempHdr, HeaderSize); FileID := FileID8; hnlines := nlines; hPixelsPerLine := PixelsPerLine; hversion := version; hLUTMode := LUTMode; hOldLutMode := LutMode; hnColors := ncolors; hOldnColors := 0; if LutMode = Pseudocolor then begin hOldLutMode := ColorLut; if (ColorTable = CustomTable) and (ncolors <= 32) then for i := 0 to nColors - 1 do begin hr[i] := RedLUT[i]; hg[i] := GreenLUT[i]; hb[i] := BlueLUT[i]; end; end; hColorStart := ColorStart; hColorEnd := ColorEnd; hFill1 := FillColor1; hFill2 := FillColor2; hTable := ColorTable; hInvertedTable := InvertedColorTable; hOldColorStart := 255 - ColorEnd; if nColors > 0 then hColorWidth := (ColorEnd - ColorStart) div nColors else hColorWidth := 1; hnExtraColors := nExtraColors; hExtraColors := ExtraColors; hForegroundIndex := ForegroundIndex; hBackgroundIndex := BackgroundIndex; {hXScale := xScale;} {68k-bug} RealToDouble(xScale, hXScale); hScaleMagnification := 1.0; hPixelAspectRatio := PixelAspectRatio; hUnitsID := 14; {Pixels. For backward compatibility only since hUnits no longer used.} if SpatiallyCalibrated then begin GetUnitsKind(UnitsKind, UnitsPerCM); hUnitsID := ord(UnitsKind) + 5; if hUnitsID > 14 then hUnitsID := 14; end; FindPoints(hp1x, hp1y, hp2x, hp2y); if fit = uncalibrated then hnCoefficients := 0 else hnCoefficients := nCoefficients; hfit := fit; for i:=1 to maxCoeff do {hCoeff[i] := Coefficient[i];} {68k-bug} RealToDouble(Coefficient[i], hCoeff[i]); hZeroClip := ZeroClip; hUM := UnitOfMeasure; hBinaryPic := BinaryPic; hSliceStart := SliceStart; hSliceEnd := SliceEnd; if StackInfo <> nil then with StackInfo^ do begin hNSlices := nSlices; hSliceSpacing := SliceSpacing; hFrameInterval := FrameInterval; hCurrentSlice := CurrentSlice; hStackType := StackType; end else begin hNSlices := 0; hSliceSpacing := 0.0; hFrameInterval := 0.0; hCurrentSlice := 0; hStackType := VolumeStack; end; hXUnit := xUnit; ByteCount := SizeOf(TempHdr); if ByteCount <> HeaderSize then begin NumToString(ByteCount, str); PutError('Internal error check: header size is incorrect.'); ExitToShell; end; if SavingSelection then begin hnlines := slines; hPixelsPerLine := sPixelsPerLine; end; err := fswrite(f, ByteCount, @TempHdr); SaveHeader := CheckIO(err); end; {with} end; procedure PackLines; {For odd width images, removes the extra bytes at the end of each line required to make RowBytes even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + BytesPerRow); DstPtr := ptr(ord4(PicBaseAddr) + PixelsPerLine); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) + BytesPerRow); DstPtr := ptr(ord4(DstPtr) + PixelsPerLine); end; end; end; procedure UnpackLines; {For odd width images, adds an extra byte to each line so RowBytes is even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * PixelsPerLine); DstPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * BytesPerRow); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine); DstPtr := ptr(ord4(DstPtr) - BytesPerRow); end; end; end; function WriteSlices (f: integer): integer; var ByteCount, SelectionSize: LongInt; i, err, SaveCS: integer; begin with info^, Info^.StackInfo^ do begin SaveCS := CurrentSlice; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; ByteCount := ImageSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if err <> 0 then leave; end; CurrentSlice := SaveCS; SelectSlice(CurrentSlice); UpdateTitleBar; WriteSlices := err; end; end; procedure WriteSelection (f: integer; sLines, sPixelsPerLine: LongInt); {Contributed by Edward J. Huff(huff@mcclb0.med.nyu.edu).} var size, offset, ByteCount, BytesDone: LongInt; src, dst: ptr; err: OSErr; begin if sPixelsPerLine > UndoBufSize then exit(WriteSelection); size := sLines * sPixelsPerLine; with info^, info^.RoiRect do begin offset := top * BytesPerRow + left; src := ptr(ord4(PicBaseAddr) + offset); BytesDone := 0; while BytesDone < size do begin ByteCount := 0; dst := UndoBuf; while ((ByteCount + sPixelsPerLine) < UndoBufSize) and (BytesDone < size) do begin BlockMove(src, dst, sPixelsPerLine); src := ptr(ord4(src) + BytesPerRow); dst := ptr(ord4(dst) + sPixelsPerLine); ByteCount := ByteCount + sPixelsPerLine; BytesDone := BytesDone + sPixelsPerLine; end; err := fswrite(f, ByteCount, UndoBuf); end; SetupUndo; {Needed for drawing roi outline} end end; procedure SaveRGBTiff(f: integer; SavingSelection: boolean); const bufsize = 12000; var i, row, pixel, count, ignore: LongInt; vstart, height, hstart, width: LongInt; buffer: packed array [0 .. bufsize] of byte; rLine, gLine, bLine: LineType; err: OSErr; begin with info^ do begin if SavingSelection then with RoiRect do begin vstart := top; height := bottom - top; hstart := left; width := right - left; end else begin vstart := 0; height := nLInes; hstart := 0; width := PixelsPerLine; end; if width > MaxLine then exit(SaveRGBTiff); ShowMeter; count := 0; for row:=0 to height - 1 do begin if (row mod 10) = 0 then UpdateMeter(((row * 100) div height), 'Saving RGB TIFF'); SelectSlice(1); GetLine(hstart, vstart + row, width, rLine); SelectSlice(2); GetLine(hstart, vstart + row, width, gLine); SelectSlice(3); GetLine(hstart, vstart + row, width, bLine); for pixel := 0 to width - 1 do begin buffer[count] := 255 - rLine[pixel]; buffer[count + 1] := 255 - gLine[pixel]; buffer[count + 2] := 255 - bLine[pixel]; count := count + 3; if count > (bufsize - 3) then begin if CheckIO(fswrite(f, count, @buffer)) <> noErr then begin exit(SaveRGBTiff); UpdateMeter(-1, ''); end; count := 0; end; end; {for} end; {for} if count > 0 then err := fswrite(f, count, @buffer); UpdateMeter(-1, ''); with StackInfo^ do begin CurrentSlice := 1; SelectSlice(CurrentSlice); end; UpdateTitleBar; end; {with} end; function SaveTiffFile (fname: str255; vnum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var f, err, i, width, height: integer; HdrSize, ByteCount, ctabSize, StackTiffDirSize, ImageDataSize: LongInt; TheInfo: FInfo; MCIDHeader: packed array[1..4] of byte; SaveColorMap, SaveAs24BitTiff: boolean; begin SaveTiffFile := false; SaveAs24BitTiff := false; ShowWatch; err := fsopen(fname, vNum, f); if CheckIO(err) <> 0 then exit(SaveTiffFile); with Info^ do begin SaveColorMap := (LutMode <> Grayscale) and (SaveAsWhat <> asRawData); if SaveAsWhat = SaveAsMCID then begin if SavingSelection then begin width := sPixelsPerLine; height := slines; end else begin width := PixelsPerLine; height := nLines; end; MCIDHeader[1] := (width - 1) mod 256; MCIDHeader[2] := (width - 1) div 256; MCIDHeader[3] := (height - 1) mod 256; MCIDHeader[4] := (height - 1) div 256; ByteCount := 4; err := fswrite(f, ByteCount, @MCIDHeader); end; HeaderOffset := TiffDirSize; ImageDataOffset := TiffDirSize + HeaderSize; if SaveColorMap then ctabSize := SizeOf(TiffColorMapType) else ctabSize := 0; StackTiffDirSize := 0; if SavingSelection then ImageDataSize := ord4(sLines) * sPixelsPerLine else ImageDataSize := ImageSize; if StackInfo <> nil then begin ImageDataSize := ImageSize * StackInfo^.nSlices; if SaveAsWhat <> asRawData then StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1); if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin SaveAs24BitTiff := true; ctabSize := 0; StackTiffDirSize := 0; end; end; if (SaveAsWhat <> asRawData) and (SaveAsWhat <> SaveAsMCID) then begin if SaveTiffDir(f, slines, sPixelsPerLine, SavingSelection, ctabSize, ImageDataSize) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; err := SetFPos(f, FSFromStart, TiffDirSize); if SaveHeader(f, slines, sPixelsPerLine, vnum, fname, SavingSelection, true) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; end; if SaveAsWhat = SaveAsMCID then KillRoi; if SaveAs24bitTiff then SaveRGBTiff(f, SavingSelection) else if SavingSelection then WriteSelection(f, sLines, sPixelsPerLine) else if StackInfo <> nil then err := WriteSlices(f) else begin ByteCount := ImageDataSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; end; if SaveAsWhat = SaveAsMCID then InvertPic; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; if SaveAsWhat = asRawData then HdrSize := 0 else if SaveAsWhat = SaveAsMCID then begin HdrSize := 4; SaveAsWhat := asRawData; end else HdrSize := HeaderSize + TiffDirSize; if SaveColorMap then SaveTiffColorMap(f, ImageDataSize); if StackTiffDirSize > 0 then err := WriteExtraTiffIFDs(f, ImageDataSize, cTabSize); err := SetEOF(f, HdrSize + ImageDataSize + ctabSize + StackTiffDirSize); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if SaveAsWhat = asRawData then begin TheInfo.fdType := 'RawD'; err := SetFInfo(fname, vnum, TheInfo); end else if TheInfo.fdType <> 'TIFF' then begin TheInfo.fdType := 'TIFF'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vNum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (SaveAsWhat <> asRawData) then begin PictureType := TiffFile; RemovePath(fname); TruncateString(fname, maxTitle); title := fname; vref := vnum; UpdateTitleBar; if StackInfo = nil then begin revertable := true; InvertedImage := false; end; end; end; if (SaveAsWhat <> asRawData) and (not RoiShowing) then Changes := false; end; {with} SaveTiffFile := true; end; procedure SaveAsTIFF (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean); var err: integer; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin if info = NoInfo then exit(SaveAsTIFF); err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') and (fdType <> 'RawD') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsTIFF) end; replacing := true; end; FNFerr: begin if SaveAsWhat = asRawData then err := create(fname, RefNum, 'Imag', 'RawD') else err := create(fname, RefNum, 'Imag', 'TIFF'); if CheckIO(err) <> 0 then exit(SaveAsTIFF); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTIFF); end; if replacing then if not RoomForFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection) then exit(SaveAsTIFF); ok := SaveTiffFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection); if ok then UpdateWindowsMenuItem; with info^ do if SavingSelection and Replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) then PictureType := Leftover; end; function SavePICTFile (fname: str255; vnum: integer; SavingSelection, NewFile: boolean): boolean; var f, err, i, v: integer; ByteCount, PICTSize: LongInt; PicH: PicHandle; fRect, frect2: rect; tPort: GrafPtr; TheInfo: FInfo; SaveInfoRec: PicInfo; HeaderSaved: boolean; SaveGDevice: GDHandle; procedure Abort; begin err := fsclose(f); if NewFile then err := FSDelete(fname, vnum); DisposeHandle(handle(PicH)); {exit(SavePICTFile)} {ppc-bug} end; begin with info^ do begin if OpPending then KillRoi; SavePICTFile := false; ShowWatch; GetPort(tPort); if SavingSelection then fRect := RoiRect else SetRect(fRect, 0, 0, PixelsPerLine, nlines); with frect do SetRect(frect2, 0, 0, right - left, bottom - top); with osPort^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; ClipRect(PicRect); LoadLUT(cTable); PicH := OpenPicture(fRect2); CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^, frect, frect2, SrcCopy, nil); ClosePicture; pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; SetPort(tPort); SetGDevice(SaveGDevice); PICTSize := GetHandleSize(handle(PicH)); if PICTSize <= 10 then begin PutError('Sorry, but there is not enough memory available to save this PICT file. Try closing some windows, or save as TIFF.'); if NewFile then err := FSDelete(fname, vnum); DisposeHandle(handle(PicH)); exit(SavePICTFile) end; err := fsopen(fname, vnum, f); err := SetFPos(f, FSFromStart, 0); SaveInfoRec := Info^; if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then begin nColors := 256; ColorStart := 0; ColorEnd := 255; LUTMode := Grayscale; IdentityFunction := true; end; HeaderSaved := SaveHeader(f, 0, 0, vnum, fname, SavingSelection, false) = 0; Info^ := SaveInfoRec; if not HeaderSaved then begin abort; exit(SavePICTFile) end; err := fswrite(f, PICTSize, pointer(PicH^)); if CheckIO(err) <> 0 then begin abort; exit(SavePICTFile) end; DisposeHandle(handle(PicH)); ByteCount := PICTSize + HeaderSize; err := SetEOF(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if TheInfo.fdType <> 'PICT' then begin TheInfo.fdType := 'PICT'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vnum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> NullPicture) then begin PictureType := PictFile; RemovePath(fname); TruncateString(fname, maxTitle); title := fname; UpdateTitleBar; vref := vnum; revertable := true; InvertedImage := false; end; Changes := false; end; end; {with} SavePICTFile := true; end; procedure SaveAsPICT (fname: str255; RefNum: integer; SavingSelection: boolean); var f, err, i: integer; where: Point; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') then begin TypeMismatch(fname); exit(SaveAsPICT) end; replacing := true; end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'PICT'); if CheckIO(err) <> 0 then exit(SaveAsPICT); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsPICT); end; ok := SavePICTFile(fname, RefNum, SavingSelection, not Replacing); if ok then UpdateWindowsMenuItem; with info^ do if SavingSelection and replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) then PictureType := Leftover; end; procedure SaveSelection (fname: str255; RefNum: integer; SaveAsSameType: boolean); var slines, spixelsPerLine: integer; begin if info = NoInfo then exit(SaveSelection); if NoSelection or NotRectangular or NotInBounds then exit(SaveSelection); if OpPending then KillRoi; with info^ do begin with RoiRect do begin sPixelsPerLine := right - left; slines := bottom - top; end; if (PictureType = PictFile) and SaveAsSameType and (SaveAsWhat <> asRawData) then SaveAsPICT(fname, RefNum, true) else SaveAsTIFF(fname, RefNum, sLines, sPixelsPerLine, true); end; end; procedure SaveAsText (fname: str255; RefNum: integer); var err, f: integer; TheInfo: FInfo; ByteCount: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(SaveAsText) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(SaveAsText); end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTExt) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveAsText); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); if CheckIO(err) <> 0 then exit(SaveAsText); err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, RefNum); if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; end; procedure SaveAsPICS (fname: str255; fRefNum: integer); const rErr = 'Error Saving PICS file.'; var err: OSErr; TheInfo: FInfo; replacing: boolean; rRefNum, i, SaveCS: integer; frect: rect; PicH: array[1..MaxSlices] of PicHandle; MinFreeRequired: LongInt; SaveGDevice: GDHandle; begin with info^, Info^.StackInfo^ do begin if StackInfo = nil then begin PutError('Only Stacks can be saved in PICS format.'); SaveAsWhat := asTiff; exit(SaveAsPICS); end; if ImageSize > MinFree then MinFreeRequired := ImageSize else MinFreeRequired := MinFree; if MaxBlock < MinFreeRequired then begin PutError('Not enough memory available to save in PICS format.'); exit(SaveAsPICS); end; err := GetFInfo(fname, fRefNum, TheInfo); if err = NoErr then with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsPICS) end; err := FSDelete(fname, fRefNum); end; ShowWatch; err := SetVol(nil, fRefNum); CreateResFile(fname); if ResError <> NoErr then exit(SaveAsPICS); rRefNum := OpenResFile(fname); SaveCS := CurrentSlice; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); with PicRect do SetRect(frect, 0, 0, right - left, bottom - top); ClipRect(frect); LoadLUT(ctable); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; PicH[i] := OpenPicture(frect); with osPort^ do CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, PicRect, frect, SrcCopy, nil); ClosePicture; if (PicH[i] = nil) or ((PicH[i] <> nil) and (GetHandleSize(handle(PicH[i])) <= 10)) then begin PutError(rErr); leave; end; AddResource(handle(PicH[i]), 'PICT', i - 1 + 128, ''); if ResError <> NoErr then begin PutError(rErr); leave; end; WriteResource(handle(PicH[i])); ReleaseResource(handle(PicH[i])); if ResError <> NoErr then begin PutError(rErr); leave; end; end; {for} pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetGDevice(SaveGDevice); CurrentSlice := SaveCS; SelectSlice(CurrentSlice); RemovePath(fname); TruncateString(fname, maxTitle); title := fname; PictureType := PicsFile; UpdateTitleBar; CloseResFile(rRefNum); if ResError = NoErr then changes := false else PutError(rErr); err := GetFInfo(fname, fRefNum, TheInfo); TheInfo.fdType := 'PICS'; TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, fRefNum, TheInfo); err := FlushVol(nil, fRefNum); UpdateWindowsMenuItem; end; {with} end; function SuggestedName: str255; var name: str255; begin case SaveAsWhat of asTiff, asPict, asMacPaint, asRawData, asPICS: begin name := info^.title; if name = 'Camera' then name := 'Untitled'; SuggestedName := name; end; AsPalette: SuggestedName := 'Palette'; AsOutline: SuggestedName := 'Outline'; end; end; function SaveAsHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; TiffID = 9; OutlineID = 14; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDlogItem(theDialog, TiffID + ord(SaveAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedName; if (item >= TiffID) and (item <= OutlineID) then begin SaveAsWhat := SaveAsWhatType(item - TiffID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedName); SelectdialogItemText(theDialog, EditTextID, 0, 32767); end; for i := TiffID to OutlineID do SetDlogItem(theDialog, i, 0); SetDlogItem(theDialog, item, 1); end; SaveAsHook := item; end; procedure SaveAs (name: str255; RefNum: integer); const CustomDialogID = 60; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; begin if SaveAsDHookProc=nil then SaveAsDHookProc:=NewRoutineDescriptor(@SaveAsHook, uppDlgHookProcInfo, GetCurrentISA); with info^ do begin if SaveAllState = SaveAllStage2 then begin name := title; RefNum := SaveRefNum; if SaveAsWhat = AsPalette then SaveAsWhat := AsTiff; end else if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if (StackInfo = nil) and (SaveAsWhat = asPICS) then SaveAsWhat := asTIFF; if (StackInfo <> nil) and ((SaveAsWhat = asPICT) or (SaveAsWhat = asMacPaint)) then SaveAsWhat := asTIFF; if name = '' then name := SuggestedName; SFPPutFile(Where, 'Save as?', name, SaveAsDHookProc, reply, CustomDialogID, nil); if not reply.good then begin SaveAllState := NoSaveAll; AbortMacro; exit(SaveAs); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if StackInfo <> nil then begin if (SaveAsWhat <> asOutline) and not ((StackInfo^.StackType = RGBStack) and (StackInfo^.nSlices = 3)) then KillRoi; SaveAllState := NoSaveAll; if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette) or (SaveAsWhat = asOutline)) then begin PutError('Stacks can only be saved in TIFF or PICS format.'); SaveAsWhat := asTIFF; exit(SaveAs); end; end; isSelection := RoiShowing and (RoiType = RectRoi); if SaveAllState = SaveAllStage1 then begin SaveRefNum := RefNum; SaveAllState := SaveAllStage2; end; case SaveAsWhat of asTiff, asRawData: if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); asPict: if isSelection then SaveAsPICT(name, RefNum, true) else SaveAsPICT(name, RefNum, false); asMacPaint: SaveAsMacPaint(name, RefNum); asPICS: SaveAsPICS(name, RefNum); AsPalette: SaveColorTable(name, RefNum); AsOutline: SaveOutline(name, RefNum); end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; procedure SaveFile; var fname: str255; size: LongInt; ok: boolean; begin if CurrentWindow = ResultsKind then begin Export('', 0); exit(SaveFile); end; if CurrentWindow = TextKind then begin SaveText; exit(SaveFile); end; if OpPending then KillRoi; with Info^ do begin fname := title; size := 0; if PictureType = TiffFile then ok := SaveTiffFile(fname, vref, 0, 0, false) else if PictureType = PictFile then ok := SavePICTFile(fname, vref, false, false) else SaveAs('', 0); end; end; function SaveChanges: integer; const yesID = 1; noID = 2; cancelID = 3; var id: integer; reply: SFReply; begin id := 0; if info^.changes then with info^ do begin if CommandPeriod or MakingStack or (macro and ((MacroCommand = DisposeC) or (MacroCommand = DisposeAllC))) then begin SaveChanges := ok; exit(SaveChanges); end; ParamText(title, '', '', ''); InitCursor; id := alert(600, nil); if id = yesID then begin SaveFile; InitCursor; end; {if yes} end; {if changes} if (id = cancelID) or ((id = yesID) and (info^.changes)) then SaveChanges := cancel else SaveChanges := ok; end; function CloseAWindow (WhichWindow: WindowPtr): integer; var i, kind, n: integer; TempInfo: InfoPtr; TempTextInfo: TextInfoPtr; SizeStr, str: str255; wp: ^WindowPtr; pcrect: rect; begin if WhichWindow = nil then exit(CloseAWindow); kind := WindowPeek(WhichWindow)^.WindowKind; CloseAWindow := ok; if WhichWindow = VideoControl then begin DisposeDialog(VideoControl); VideoControl := nil; exit(CloseAWindow); end; case kind of PicKind: begin Info := pointer(WindowPeek(WhichWindow)^.RefCon); with Info^ do begin if PicNum = 0 then begin beep; exit(CloseAWindow); end; if SaveChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DeleteMenuItem(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows); for i := PicNum to nPics - 1 do begin PicWindow[i] := PicWindow[i + 1]; TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); TempInfo^.PicNum := i end; if PictureType = BlankField then BlankFieldInfo := nil; if (PictureType = FrameGrabberType) and (FrameGrabber = QTvdig) then CloseVdig; if StackInfo <> nil then begin with StackInfo^ do for i := 1 to nSlices do DisposeHandle(PicBaseH[i]); DisposePtr(pointer(StackInfo)); end else begin if not MakingStack then DisposeHandle(PicBaseHandle); end; DisposeWindow(WhichWindow); CloseCPort(osPort); DisposePtr(ptr(osPort)); DisposeRgn(roiRgn); if DataH <> nil then DisposeHandle(DataH); nPics := nPics - 1; OpPending := false; isInsertionPoint := false; DisposePtr(pointer(Info)); Info := NoInfo; if (nPics = 0) and (not finished) then with info^ do begin LoadLUT(info^.cTable); if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then DrawMap; end; PicLeft := PicLeftBase; PicTop := PicTopBase; end; end; {PicKind} HistoKind: begin DisposeWindow(HistoWindow); HistoWindow := nil; ContinuousHistogram := false; end; ProfilePlotKind, CalibrationPlotKind: begin DisposeWindow(PlotWindow); PlotWindow := nil; KillPicture(PlotPICT); PlotPICT := nil; end; ResultsKind: begin DisposeWindow(ResultsWindow); ResultsWindow := nil; TEDispose(ListTE); end; TextKind: begin TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon); if TextInfo <> nil then with TextInfo^ do begin if SaveTextChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DisposeWindow(TextWindowPtr); DeleteMenuItem(WindowsMenuH, WindowsMenuItems - 1 + WindowNum); TEDispose(TextTE); DisposePtr(ptr(TextInfo)); TextInfo := nil; for i := WindowNum to nTextWindows - 1 do begin TextWindow[i] := TextWindow[i + 1]; TempTextInfo := pointer(WindowPeek(TextWindow[i])^.RefCon); TempTextInfo^.WindowNum := i end; nTextWindows := nTextWindows - 1; end; end; PasteControlKind: begin GetWindowRect(PasteControl, pcrect); with pcrect do begin PasteControlLeft := left; PasteControlTop := top; end; DisposeWindow(PasteControl); PasteControl := nil; wp := pointer(GhostWindow); wp^ := nil; end; otherwise ; end; {case} end; procedure DoClose; var ignore: integer; fwptr: WindowPtr; kind: integer; begin fwptr := FrontWindow; if fwptr <> nil then begin if fwptr = VideoControl then begin DisposeDialog(VideoControl); VideoControl := nil; exit(DoClose); end; kind := WindowPeek(fwptr)^.WindowKind; if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) or (Kind = TextKind) then ignore := CloseAWindow(fwptr); end; end; procedure Read4BitTIFF (f: integer); var vloc, hloc, i: integer; ByteCount, count: LongInt; err: OSErr; UnpackedLine, PackedLine: LineType; begin with info^ do begin if PixelsPerLine > MaxLine then exit(Read4BitTIFF); ByteCount := (PixelsPerLine + 1) div 2; for vloc := 0 to nLines - 1 do begin err := FSRead(f, ByteCount, @PackedLine); i := 0; for hloc := 0 to PixelsPerLine - 1 do if odd(hloc) then begin UnpackedLine[hloc] := bsl(band(PackedLine[i], $F), 4); i := i + 1; end else UnpackedLine[hloc] := band(PackedLine[i], $F0); PutLine(0, vloc, PixelsPerLine, UnpackedLine); end; end; {with} end; {$POP} procedure CheckFileSize(f:integer; var size: LongInt; offset: LongInt); {Check to make sure we don't read past the end of file.} var FileSize: LongInt; err: OSErr; begin err := GetEof(f, FileSize); if (offset + size) > FileSize then begin size := FileSize - offset; if size < 0 then size := 0; end; end; procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTable); var i, err, SaveCS: integer; h: handle; DataSize: LongInt; PartialStack: boolean; begin ShowMessage(CmdPeriodToStop); PartialStack := false; with info^ do begin StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(ReadStackSlices); end; with info^, info^.StackInfo^ do begin nSlices := nExtraImages + 1; CurrentSlice := TempStackInfo.CurrentSlice; if (CurrentSlice < 1) or (CurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := TempStackInfo.SliceSpacing; FrameInterval := TempStackInfo.FrameInterval; StackType := TempStackInfo.StackType; SaveCS := CurrentSlice; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := GetBigHandle(PixMapSize); if h = nil then begin nSlices := i - 1; PutError(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.')); PartialStack := true; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; err := SetFPos(f, fsFromStart, table[i - 1].offset); CheckFileSize(f, DataSize, table[i - 1].offset); if DataSize > 0 then err := fsread(f, DataSize, h^); if odd(PixelsPerLine) then UnpackLines; if InvertedImage then InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; if i < nSlices then PartialStack := true; nSlices := i; wait(60); leave; end; end; {for} CurrentSlice := SaveCS; if CurrentSlice > nSlices then CurrentSlice := 1; SelectSlice(CurrentSlice); if PartialStack then begin vref := 0; PictureType := NewPicture; title := concat(title, '@'); end; UpdateTitleBar; UpdateWindowsMenuItem; end; end; procedure OpenStack (f: integer); var table: TiffIFDTable; i, nExtraImages: integer; where: LongInt; begin nExtraImages := TempStackInfo.nSlices - 1; with info^ do begin where := ImageDataOffset; for i := 1 to nExtraImages do with table[i] do begin iWidth := PixelsPerLine; iHeight := nLines; where := where + ImageSize; Offset := where; invert := false; end; ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenExtraTiffImages (f: integer; NextTiffIFD: LongInt); var table: TiffIFDTable; TiffInfo: TiffInfoRec; i, nExtraImages: integer; AllSameSize: boolean; begin nExtraImages := 0; repeat if not OpenTiffDirectory(f, NextTiffIFD, TiffInfo, false) then exit(OpenExtraTiffImages); nExtraImages := nExtraImages + 1; with TiffInfo, table[nExtraImages] do begin iWidth := width; iHeight := height; Offset := OffsetToData; invert := ZeroIsBlack; NextTiffIFD := NextIFD; end; until (NextTiffIFD = 0) or (nExtraImages = MaxSlices); AllSameSize := true; with info^ do begin for i := 1 to nExtraImages do AllSameSize := AllSameSize and (PixelsPerLine = table[i].iWidth) and (nLines = table[i].iHeight); if AllSameSize and not odd(PixelsPerLine) then ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenRGBTiff(f: integer); const bufsize = 12000; var i, row, pixel, rgbPixel, ignore, SaveRow: integer; NextUpdate, count: LongInt; buffer: packed array [0 .. bufsize] of byte; rLine, gLine, bLine: LineType; err: OSErr; MaskRect: rect; begin with info^ do begin if PixelsPerLine > MaxLine then exit(OpenRGBTiff); if not MakeStackFromWindow then exit(OpenRGBTiff); if not AddSlice(false) then begin info^.changes := false; ignore := CloseAWindow(info^.wptr); exit(OpenRGBTiff); end; if not AddSlice(false) then begin info^.changes := false; ignore := CloseAWindow(info^.wptr); exit(OpenRGBTiff); end; SaveRow:=0; NextUpdate:=TickCount+6; err := SetFPos(f, fsFromStart, ImageDataOffset); count := 0; for row:=0 to nLines - 1 do begin for pixel := 0 to PixelsPerLine - 1 do begin if count <= 0 then begin count := bufsize; err := fsread(f, count, @buffer); if err <> -39 then {eof error} if CheckIO(err) <> noErr then exit(OpenRGBTiff); rgbPixel := 0; end; rLine[pixel] := 255 - buffer[rgbPixel]; gLine[pixel] := 255 - buffer[rgbPixel + 1]; bLine[pixel] := 255 - buffer[rgbPixel + 2]; rgbPixel := rgbPixel + 3; count := count - 3; end; SelectSlice(1); PutLine(0, row, PixelsPerLine, rLine); if TickCount>=NextUpdate then begin SetRect(MaskRect, 0, SaveRow, PixelsPerLine, row+1); UpdateScreen(MaskRect); SaveRow:=row + 1; NextUpdate:=TickCount+6; end; SelectSlice(2); PutLine(0, row, PixelsPerLine, gLine); SelectSlice(3); PutLine(0, row, PixelsPerLine, bLine); end; {for} with StackInfo^ do begin CurrentSlice := 1; SelectSlice(CurrentSlice); StackType := rgbStack; end; SetRect(MaskRect, 0, SaveRow, PixelsPerLine, nLines); UpdateScreen(MaskRect); UpdateTitleBar; ResetGrayMap; OpeningRGB := true; end; {with} end; function OpenFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; iptr, p: ptr; SaveInfo: InfoPtr; TiffInfo: TiffInfoRec; isRGBTiff: boolean; begin OpenFile := false; ShowWatch; err := fsopen(fname, vNum, f); SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(f); exit(OpenFile) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); with Info^ do begin ColorMapOffset := 0; if not OpenHeader(f, fname, vnum, TiffInfo) then begin DisposePtr(iptr); err := fsclose(f); Info := SaveInfo; exit(OpenFile) end; if WhatToOpen = OpenTIFF then begin NextTiffIFD := TiffInfo.NextIFD; isRGBTiff := TiffInfo.SamplesPerPixel = 3; end else begin NextTiffIFD := 0; isRGBTiff := false; end; p := GetImageMemory(SaveInfo); if p = nil then begin err := fsclose(f); exit(OpenFile) end; PicBaseAddr := p; MakeNewWindow(fname); err := SetFPos(f, fsFromStart, ImageDataOffset); if PictureType = FourBitTIFF then Read4BitTIFF(f) else if not isRGBTiff then begin DataSize := nlines * PixelsPerLine; CheckFileSize(f, DataSize, ImageDataOffset); if DataSize > 0 then err := fsread(f, DataSize, PicBaseAddr); if CheckIO(err) <> NoErr then begin err := fsclose(f); exit(OpenFile) end; end; if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then UnpackLines; if (PictureType = Imported) and (ImportInvert or (WhatToImport = ImportMCID)) then InvertedImage := true; if InvertedImage then InvertPic; if PictureType = FourBitTIFF then PictureType := imported; if (ColorMapOffset > 0) and (fileVersion = 0) then begin FixColors; {Fix colors, if necessary, of imported color TIFF files.} WhatToUndo := NothingToUndo; end; vref := vnum; if PixMapSize > UndoBufSize then PutWarning; revertable := true; end; {with} if isRGBTiff then OpenRGBTiff(f) else if TempStackInfo.nSlices > 0 then OpenStack(f) else if NextTiffIFD > 0 then OpenExtraTiffImages(f, NextTiffIFD); err := fsclose(f); OpenFile := true; end; {$PUSH} {$D-} procedure ScaleToEightBits (f: integer); type PixelLUTType = packed array[0..65535] of byte; PixelLUTPtr = ^PixelLUTType; IntLineType = array[0..MaxLine] of integer; var line: LineType; i, j, value, LineSize, offset: LongInt; ScaleFactor: extended; hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer; PixelLUT: PixelLUTPtr; str1, str2: str255; err: integer; aLine: IntLineType; LinesPerUpdate: integer; procedure reset; var DataSize, SliceOffset: LongInt; p: ptr; begin with info^ do begin if StackInfo <> nil then SliceOffset := ImageSize * 2 * (StackInfo^.CurrentSlice - 1) else SliceOffset := 0; err := SetFPos(f, fsFromStart, ImageDataOffset + SliceOffset); if DataH <> nil then begin if offset = -1 then begin hlock(DataH); DataSize := ImageSize * 2; CheckFileSize(f, DataSize, ImageDataOffset); if DataSize > 0 then err := fsread(f, DataSize, DataH^); end; offset := 0 end; end; end; procedure GetIntLine (var line: IntLineType); type atype = packed array[1..2] of char; var p: ptr; a: atype; c: char; i: integer; begin with info^ do begin if DataH <> nil then begin p := ptr(ord4(DataH^) + offset); if (offset + LineSize) <= (PixMapSize * 2) then BlockMove(p, @line, LineSize); offset := offset + LineSize; end else err := fsread(f, LineSize, @line); if LittleEndian then for i := 0 to LineSize div 2 - 1 do begin a := atype(line[i]); c := a[1]; a[1] := a[2]; a[2] := c; line[i] := integer(a) end; end; end; procedure FindMinAndMax; var vloc, hloc: integer; value: LongInt; begin with info^ do begin AbsoluteMin := 999999; AbsoluteMax := -999999; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value > AbsoluteMax then AbsoluteMax := value; if value < AbsoluteMin then begin if ImportingDicom then begin if value <> -32767 then AbsoluteMin := value end else AbsoluteMin := value; end; {value <AbsoluteMin} end {for hloc:=} end;{for vloc := } if (CurrentMin = 0) and (CurrentMax = 0) then begin CurrentMin := AbsoluteMin; CurrentMax := AbsoluteMax; end; reset; end; {with} end; begin with info^ do begin PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType))); if PixelLUT = nil then begin if DataH <> nil then begin DisposeHandle(DataH); DataH := nil end; PutError('Not enough memory to do 16 to 8-bit scaling.'); AbortMacro; exit(ScaleToEightBits); end; offset := -1; reset; LineSize := PixelsPerLine * 2; LinesPerUpdate := 40000 div LineSize; if (AbsoluteMin = 0) and (AbsoluteMax = 0) then FindMinAndMax; str1 := concat('min=', long2str(CurrentMin), ' (', long2str(AbsoluteMin), ')', crStr, 'max=', long2str(CurrentMax), ' (', long2str(AbsoluteMax), ')'); ScaleFactor := 253.0 / (CurrentMax - CurrentMin); RealToString(ScaleFactor, 1, 4, str2); ShowMessage(concat(str1, crStr, 'scale factor= ', str2)); j := 0; for i := CurrentMin to CurrentMax do begin PixelLUT^[j] := round((i - CurrentMin) * ScaleFactor + 1); j := j + 1; end; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value < CurrentMin then value := CurrentMin; if value > CurrentMax then value := CurrentMax; line[hloc] := PixelLUT^[value - CurrentMin]; i := i + 1; end; PutLine(0, vloc, PixelsPerLine, line); end; if fit = StraightLine then begin nCoefficients := 2; coefficient[2] := (CurrentMin - CurrentMax) / 253.0; coefficient[1] := CurrentMax - coefficient[2]; nKnownValues := 0; ZeroClip := false; UpdateTitleBar; end; DisposePtr(ptr(PixelLUT)); if DataH <> nil then begin DisposeHandle(DataH); DataH := nil end; end; {with} end; procedure RescaleToEightBits; var range: LongInt; err: OSErr; f: integer; begin with info^ do begin ShowWatch; KillRoi; DisableDensitySlice; err := fsopen(title, vref, f); if CheckIO(err) <> 0 then exit(RescaleToEightBits); range := CurrentMax - CurrentMin; if ColorStart > 0 then CurrentMax := CurrentMax - round((ColorStart / 255.0) * range) else CurrentMax := AbsoluteMax; if ColorEnd < 255 then CurrentMin := CurrentMin + round(((255 - ColorEnd) / 255.0) * range) else CurrentMin := AbsoluteMin; ScaleToEightBits(f); err := fsclose(f); InvertPic; UpdatePicWindow; ResetMap; if fit <> uncalibrated then GenerateValues; end; end; procedure Import16BitSlices (f: integer); var i, err: integer; h: handle; DataSize, nImages, MaxImages, FileSize: LongInt; begin with info^ do begin nImages := ImportCustomSlices; err := GetEof(f, FileSize); MaxImages := (FileSize - ImportCustomOffset) div (ImageSize * 2); if nImages > MaxImages then nImages := MaxImages; if nImages < 2 then exit(Import16BitSlices); ShowMessage(CmdPeriodToStop); StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(Import16BitSlices); end; {with} with info^, info^.StackInfo^ do begin nSlices := nImages; SliceSpacing := 0.0; FrameInterval := 0.0; StackType := VolumeStack; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := NewHandle(PixMapSize); if h = nil then begin nSlices := i - 1; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; ScaleToEightBits(f); InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposeHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutError(concat('Not enough memory to open all ', long2str(nImages), ' slices in the stack.')); end; CurrentSlice := 1; SelectSlice(CurrentSlice); if ImportCalibrate and ImportAutoScale then begin RemoveDensityCalibration; ImportCalibrate := false; end; UpdateTitleBar; UpdateWindowsMenuItem; end; end; function Import16BitFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i: LongInt; err: OSErr; f: integer; line, pixel: integer; begin Import16BitFile := false; if ImportCustomWidth > MaxLine then exit(Import16BitFile); if not NewPicWindow(fname, ImportCustomWidth, ImportCustomHeight) then exit(Import16BitFile); ShowWatch; err := fsopen(fname, vNum, f); with info^ do begin PictureType := imported; ImageDataOffset := ImportCustomOffset; DataType := ImportCustomDepth; vref := vnum; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; LittleEndian := ImportSwapBytes; if ImportCalibrate then begin fit := StraightLine; nCoefficients := 2; coefficient[1] := 0.0; {ScaleToEightBits changes these coefficient} coefficient[2] := 1.0; end else RemoveDensityCalibration; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; DataH := GetBigHandle(PixMapSize * 2); ScaleToEightBits(f); if ImportCustomSlices > 1 then Import16BitSlices(f); err := fsclose(f); InvertPic; if PixMapSize > UndoBufSize then PutWarning; revertable := false; end; {with} Import16BitFile := true; end; procedure InitPictBuffer (howBig: LongInt); begin repeat PictBuffer := NewPtr(howBig); if PictBuffer = nil then howBig := howBig div 2; until PictBuffer <> nil; DisposePtr(PictBuffer); PictBuffer := NewPtr(howBig div 2); end; procedure FillPictBuffer; var count: LongInt; err: OSErr; begin count := GetPtrSize(PictBuffer); if not fitsInPictBuffer then begin err := FSRead(PictF, count, PictBuffer); if err <> NoErr then PictReadErr := true; end; bytesInPictBuffer := count; curPictBufPtr := PictBuffer; end; procedure GetPICTData (dataPtr: Ptr; byteCount: Integer); {Input picture spooler routine taken from Apple's PICTViewer example program.} var count: LongInt; anErr: OSErr; begin count := byteCount; repeat if bytesInPictBuffer >= count then begin BlockMove(curPictBufPtr, dataPtr, count); curPictBufPtr := Ptr(Ord4(curPictBufPtr) + count); bytesInPictBuffer := bytesInPictBuffer - count; count := 0; end else begin {Not enough in buffer} if bytesInPictBuffer > 0 then begin BlockMove(curPictBufPtr, dataPtr, bytesInPictBuffer); dataPtr := Ptr(Ord4(dataPtr) + bytesInPictBuffer); count := count - bytesInPictBuffer; end; FillPictBuffer; end; until count = 0; end; procedure BitInfo (var srcBits: PixMap; var srcRect, dstRect: rect; mode: integer; maskRgn: rgnHandle); var i, size: integer; begin if BitInfoCount = 0 then begin PictSrcRect := srcRect; if srcBits.rowBytes < 0 then with srcBits.pmTable^^ do begin {Make sure it is a PixMap.} size := ctSize; if size > 255 then size := 255; if size > 0 then begin BitInfoCount := BitInfoCount + 1; if not UseExistingLUT then with info^ do begin for i := 0 to size do cTable[i].rgb := ctTable[i].rgb; LutMode := ColorLut; SetupPseudocolor; end; end; end; {with} end; end; procedure GetLUTFromPict (thePict: PicHandle); {Refer to "Screen Dump FKEY for Color Picts", February 1988 MacTutor.} type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SavePort: GrafPtr; err: osErr; TempPort: CGrafPort; limbo: rect; xxscale, yyscale: extended; begin GetPort(SavePort); OpenCPort(@TempPort); SetStdCProcs(tempProcs); tempProcs.bitsProc := BitInfoProc; tempProcs.getPicProc := GetPICTDataProc; PictSrcRect := thePict^^.picFrame; BitInfoCount := 0; TempPort.grafProcs := @tempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; limbo := thePict^^.picFrame; OffsetRect(limbo, 10000, 10000); if not PictReadErr then DrawPicture(thePict, limbo); CloseCPort(@TempPort); SetPort(SavePort); with info^, PictSrcRect do begin LoadLUT(cTable); xxScale := (right - left) / PixelsPerLine; yyScale := (bottom - top) / nLines; if (xxScale > 1.0) and ((PixelsPerLine * xxScale) <= MaxLine) and ((xxScale - yyScale) < 0.1) then begin PixelsPerLine := right - left; nLines := bottom - top; end; end; {with} end; function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean} var err: OSErr; i: integer; iptr, p: ptr; PictSize, HowBig: LongInt; thePict: PicHandle; tPort: GrafPtr; tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; SaveInfo: InfoPtr; SaveGDevice: GDHandle; TiffInfo: TiffInfoRec; procedure Abort; begin if not reverting then begin DisposePtr(pointer(Info)); Info := SaveInfo; LoadLUT(info^.cTable); end; if thePict <> nil then DisposeHandle(handle(thePict)); if PictF <> 0 then err := fsclose(PictF); {exit(OpenPict);} {ppc-bug} end; begin if BitInfoProc=nil then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA); if GetPictDataProc=nil then GetPictDataProc:=NewRoutineDescriptor(@GetPictData, uppQDGetPicProcInfo, GetCurrentISA); PictF := 0; thePict := nil; OpenPict := false; PictReadErr := false; ShowWatch; SaveInfo := Info; err := fsopen(fname, vNum, PictF); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; if not Reverting then begin iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(PictF); exit(OpenPict) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); end; with Info^ do begin err := GetEof(PictF, PictSize); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; PictSize := PictSize - 512; if PictSize <= 0 then begin Abort; exit(OpenPict) end; WhatToOpen := OpenPICT2; if not OpenHeader(PictF, fname, vnum, TiffInfo) then begin Abort; exit(OpenPict) end; thePict := PicHandle(NewHandle(SizeOf(Picture))); if thePict = nil then begin Abort; exit(OpenPict); end; err := SetFPos(PictF, fsFromStart, 512); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; howBig := SizeOf(Picture); err := FSRead(PictF, howBig, Pointer(thePict^)); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; with thePict^^.PicFrame do begin nlines := bottom - top; PixelsPerLine := right - left; end; {....} err := GetEof(PictF, howBig); howBig := howBig - (512 + SizeOf(Picture)); InitPictBuffer(HowBig * 2); if GetPtrSize(PictBuffer) >= howBig then begin err := FSRead(PictF, howBig, PictBuffer); if CheckIO(err) <> NoErr then begin DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; fitsInPictBuffer := true; end else fitsInPictBuffer := false; if (LutMode = ColorLut) or (LutMode = CustomGrayscale) or (fileVersion = 0) then GetLUTFromPict(thePict); if not Reverting then begin p := GetImageMemory(SaveInfo); if p = nil then begin DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; PicBaseAddr := p; MakeNewWindow(fname); if ScreenDepth <> 8 then begin SelectAll(false); DoOperation(EraseOp); KillRoi; end; end; if (PixMapSize > UndoBufSize) and (not Reverting) then begin PutWarning; ShowWatch; end; if isGrayScaleLUT then ResetGrayMap; SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); EraseRect(PicRect); SaveProcsPtr := pointer(osPort^.grafProcs); SetStdCProcs(tempProcs); tempProcs.getPicProc := GetPICTDataProc; osPort^.grafProcs := @TempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, PicRect); osPort^.grafProcs := pointer(SaveProcsPtr); DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetPort(tPort); SetGDevice(SaveGDevice); vref := vnum; PictureType := PictFile; revertable := true; end; {with} err := fsclose(PictF); SetupUndo; if not PictReadErr then OpenPict := true; end; procedure GetCLUT (thePict: PicHandle); type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; err: osErr; begin with info^ do begin SetPort(GrafPtr(osPort)); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := BitInfoProc; BitInfoCount := 0; osPort^.grafProcs := @tempProcs; DrawPicture(thePict, thePict^^.picFrame); osPort^.grafProcs := pointer(SaveProcsPtr); LoadLUT(cTable); end; end; function OpenPICS (name: str255; fRefNum: integer): boolean; var RefNum, picID, hOffset, vOffset, nPICS, i: integer; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; SaveGDevice: GDHandle; begin if BitInfoProc=nil then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA); OpenPics := false; if MaxBlock < MinFree then begin PutError('Insufficient memory to open PICS file.'); exit(OpenPICS); end; ShowWatch; err := SetVol(nil, fRefNum); RefNum := OpenResFile(name); if RefNum = -1 then begin PutError('Unable to open PICS file.'); exit(OpenPICS); end; nPICS := Count1Resources('PICT'); if nPICS < 1 then begin PutError('No PICTs found.'); CloseResFile(RefNum); exit(OpenPICS); end; PicH := GetPicture(128); if PicH = nil then begin CloseResFile(RefNum); exit(OpenPICS); end; FrameRect := PicH^^.PicFrame; with FrameRect do begin hOffset := left; vOffset := top; right := right - hOffset; bottom := bottom - vOffset; left := 0; top := 0; end; with FrameRect do if not NewPicWindow(name, right - left, bottom - top) then begin CloseResFile(RefNum); exit(OpenPICS); end; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then begin CloseResFile(RefNum); exit(OpenPICS); end; with StackInfo^ do begin SliceSpacing := 0.0; FrameInterval := 0.0; StackType := VolumeStack; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; if not UseExistingLUT then GetCLUT(picH); with info^, Info^.StackInfo^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmBackColor(WhiteIndex); EraseRect(PicRect); DrawPicture(picH, PicRect); DisposeHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; picID := 129; MemError := false; for i := 2 to nPICS do begin PicH := GetPicture(picID); if (PicH = nil) or (ResError <> NoErr) then Leave; h := GetBigHandle(PixMapSize); if h = nil then begin if PicH <> nil then DisposeHandle(handle(picH)); MemError := true; Leave; end; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); FrameRect := PicH^^.PicFrame; with FrameRect do begin right := right - hOffset; bottom := bottom - vOffset; left := left - hOffset; top := top - vOffset; end; SetGDevice(osGDevice); EraseRect(PicRect); if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposeHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; UpdateTitleBar; Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; end; CloseResFile(RefNum); if MemError then PutError('Not enough memory to open all images in PICS file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; UpdateTitleBar; UpdateWindowsMenuItem; if not MemError and not Aborted then OpenPICS := true; end; {with} end; {$D-} procedure OpenAll (RefNum: integer); {Opens all appropriate files in a folder. Original version contributed by Ira Rampil.} var OpenedOK: boolean; index,vRefNum: integer; name: Str255; ftype: OSType; err: OSErr; PB: CInfoPBRec; dirID,ProcID:LongInt; begin vRefNum:=0; err:=GetWDInfo(RefNum,vRefNum,dirID,ProcID); if err<>noErr then exit(OpenAll); index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioDirID:=DirID; ioFDirIndex := index; err := PBGetCatInfoSync(@PB); {ppc-bug} if err = fnfErr then exit(OpenAll); ftype := ioFlFndrInfo.fdType; end; if ftype = 'IPIC' then begin WhatToOpen := OpenImage; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PICT' then begin if not OpenPICT(name, RefNum, false) then exit(OpenAll) end else if ftype = 'TIFF' then begin WhatToOpen := OpenTiff; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PNTG' then if not OpenMacPaint(name, RefNum) then exit(OpenAll); if CommandPeriod or (nPics>=MaxPics) then begin beep; exit(OpenAll); end; end; {while} end; function OpenDialogHook (item: integer; theDialog: DialogPtr): integer; const OpenAllID = 11; KeepLutID = 12; var i: integer; begin if (item = -1) and UseExistingLUT then SetDlogItem(theDialog, KeepLutID, 1); if item = OpenAllID then begin OpenAllFiles := not OpenAllFiles; SetDlogItem(theDialog, OpenAllID, ord(OpenAllFiles)); end; if item = KeepLutID then begin UseExistingLUT := not UseExistingLUT; SetDlogItem(theDialog, KeepLutID, ord(UseExistingLut)); end; OpenDialogHook := item; end; function isTiffFile (fname: str255; RefNum: integer): boolean; {Returns true if the first 16-bit word of the file contains 'MM' or 'II' and the second contains 42.} var f: integer; ByteCount: LongInt; hdr: array[1..512] of integer; err: OSErr; begin err := fsopen(fname, RefNum, f); err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); isTiffFile := ((hdr[1] = $4949) and (hdr[2] = $2A00) or (hdr[1] = $4D4D) and (hdr[2] = $002A)); err := fsclose(f); end; function DoOpen (FileName: str255; RefNum: integer): boolean; const MyDialogID = 70; var where: Point; reply: SFReply; b: boolean; TypeList: array[0..10] of OSType; FileType: OSType; OKToContinue: boolean; FinderInfo: FInfo; err: OSErr; begin if OpenDHookProc=nil then OpenDHookProc:=NewRoutineDescriptor(@OpenDialogHook, uppDlgHookProcInfo, GetCurrentISA); KillOperation; DisableDensitySlice; OpenAllFiles := false; UseExistingLUT := false; OKToContinue := false; if FileName = '' then begin where.v := 50; where.h := 50; typeList[0] := 'IPIC'; typeList[1] := 'PICT'; typeList[2] := 'TIFF'; typeList[3] := 'ICOL'; {Color Tables} typeList[4] := 'PX05'; {PixelPaint LUT} typeList[5] := 'CLUT'; {Klutz LUT} typeList[6] := 'drwC'; {Canvas LUT} typeList[7] := 'PNTG'; {MacPaint} typeList[8] := 'PICS'; typeList[9] := 'Iout'; {Outlines} typeList[10] := 'TEXT'; SFPGetFile(Where, '', nil, 11, @TypeList, OpenDHookProc, reply, MyDialogID, nil); if reply.good then with reply do begin FileName := fname; FileType := ftype; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; OKToContinue := true; end; if reply.good and OpenAllFiles then begin OpenAll(RefNum); exit(DoOpen); end; end else begin err := GetFInfo(FileName, RefNum, FinderInfo); FileType := FinderInfo.fdType; OKToContinue := true; end; DoOpen := OKToContinue; if OKToContinue then begin if FileType = 'IPIC' then begin WhatToOpen := OpenImage; b := OpenFile(FileName, RefNum) end else if FileType = 'PICT' then begin b := OpenPICT(FileName, RefNum, false) end else if FileType = 'TIFF' then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else if FileType = 'ICOL' then OpenColorTable(FileName, RefNum) else if FileType = 'PX05' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'CLUT' then ImportPalette('CLUT', FileName, RefNum) else if FileType = 'drwC' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'PNTG' then b := OpenMacPaint(FileName, RefNum) else if FileType = 'PICS' then b := OpenPICS(FileName, RefNum) else if FileType = 'Iout' then OpenOutline(FileName, RefNum) else if FileType = 'TEXT' then begin if isTiffFile(FileName, RefNum) and not OptionKeyWasDown then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else b := OpenTextFile(FileName, RefNum) end else begin WhatToOpen := OpenUnknown; b := OpenFile(FileName, RefNum) end; info^.ScaleToFitWindow := false; if macro then GenerateValues; end; end; procedure ImportAllFiles (RefNum: integer); var OpenedOK: boolean; index, vRefNum: integer; name: Str255; ftype: OSType; err: OSErr; PB: CInfoPBRec; dirID,ProcID:LongInt; begin vRefNum:=0; err:=GetWDInfo(RefNum, vRefNum, dirID, ProcID); if err<>noErr then exit(ImportAllFiles); index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioDirID:=dirID; ioFDirIndex := index; err := PBGetCatInfoSync(@PB); {ppc-bug} if err = fnfErr then exit(ImportAllFiles); ftype := ioFlFndrInfo.fdType; end; if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then begin if not Import16BitFile(name, RefNum) then exit(ImportAllFiles); end else begin if not OpenFile(name, RefNum) then exit(ImportAllFiles); end; if CommandPeriod or (nPics>=MaxPics) then begin beep; exit(ImportAllFiles); end; end; {while} end; procedure EditImportParameters; const WidthID = 2; HeightID = 3; OffsetID = 4; SlicesID = 5; FixedID = 6; MinID = 7; MaxID = 8; var mylog: DialogPtr; item, fwidth: integer; begin mylog := GetNewDialog(110, nil, pointer(-1)); SetDNum(MyLog, WidthID, ImportCustomWidth); SelectdialogItemText(MyLog, WidthID, 0, 32767); SetDNum(MyLog, HeightID, ImportCustomHeight); SetDNum(MyLog, SlicesID, ImportCustomSlices); SetDNum(MyLog, OffsetID, ImportCustomOffset); SetDlogItem(MyLog, FixedID, ord(not ImportAutoScale)); if WhatToImport = ImportText then fwidth := 2 else fwidth := 0; SetDReal(MyLog, MinID, ImportMin, fwidth); SetDReal(MyLog, MaxID, ImportMax, fwidth); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); if item = WidthID then begin ImportCustomWidth := GetDNum(MyLog, WidthID); if (ImportCustomWidth < 0) or (ImportCustomWidth > MaxPicSize) then begin ImportCustomWidth := 512; SetDNum(MyLog, WidthID, ImportCustomWidth); end; end; if item = HeightID then begin ImportCustomHeight := GetDNum(MyLog, HeightID); if ImportCustomHeight < 0 then begin ImportCustomHeight := 512; SetDNum(MyLog, HeightID, ImportCustomHeight); end; end; if item = SlicesID then begin ImportCustomSlices := GetDNum(MyLog, SlicesID); if ImportCustomSlices < 0 then begin ImportCustomSlices := 1; SetDNum(MyLog, SlicesID, ImportCustomSlices); end; end; if item = OffsetID then begin ImportCustomOffset := GetDNum(MyLog, OffsetID); if ImportCustomOffset < 0 then begin ImportCustomOffset := 0; SetDNum(MyLog, OffsetID, ImportCustomOffset); end; end; if item = FixedID then begin ImportAutoScale := not ImportAutoScale; SetDlogItem(mylog, FixedID, ord(not ImportAutoScale)); end; if item = MinID then begin ImportMin := GetDReal(MyLog, MinID); ImportAutoScale := false; SetDlogItem(MyLog, FixedID, 1); end; if item = MaxID then begin ImportMax := GetDReal(MyLog, MaxID); ImportAutoScale := false; SetDlogItem(MyLog, FixedID, 1); end; until item = ok; DisposeDialog(mylog); end; function ImportDialogHook (item: integer; myLog: DialogPtr): integer; const TiffID = 11; DicomID = 12; TextID = 13; LutID = 14; CustomID = 15; WidthAndHeightID = 16; OffsetID = 17; EightBitsID = 18; SixteenBitsUnsignedID = 19; SixteenBitsSignedID = 20; SwapBytesID = 21; ImportAllID = 22; EditID = 23; CalibrateID = 24; InvertID = 25; var i: integer; procedure SetRadioButtons1; var i: integer; begin SetDlogItem(mylog, TiffID, 0); SetDlogItem(mylog, DicomID, 0); SetDlogItem(mylog, LutID, 0); SetDlogItem(mylog, TextID, 0); SetDlogItem(mylog, CustomID, 0); case WhatToImport of ImportTiff: SetDlogItem(mylog, TiffID, 1); ImportDicom: SetDlogItem(mylog, DicomID, 1); ImportLUT: SetDlogItem(mylog, LutID, 1); ImportText: SetDlogItem(mylog, TextID, 1); ImportCustom: SetDlogItem(mylog, CustomID, 1); end; end; procedure SetRadioButtons2; var i: integer; begin SetDlogItem(mylog, EightBitsID, 0); SetDlogItem(mylog, SixteenBitsUnsignedID, 0); SetDlogItem(mylog, SixteenBitsSignedID, 0); case ImportCustomDepth of EightBits: SetDlogItem(mylog, EightBitsID, 1); SixteenBitsUnsigned: SetDlogItem(mylog, SixteenBitsUnsignedID, 1); SixteenBitsSigned: SetDlogItem(mylog, SixteenBitsSignedID, 1); end; end; procedure ShowParameters; var str1, str2, str3: str255; begin NumToString(ImportCustomWidth, str1); NumToString(ImportCustomHeight, str2); NumToString(ImportCustomOffset, str3); ParamText(str1, str2, str3, ''); end; begin if item = -1 then begin {Initialize} SetRadioButtons1; SetRadioButtons2; ShowParameters; SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); SetDlogItem(mylog, ImportAllID, ord(ImportAll)); SetDlogItem(mylog, InvertID, ord(ImportInvert)); SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= TiffID) and (item <= CustomID) then begin case item of TiffID: WhatToImport := ImportTiff; DicomID: WhatToImport := ImportDicom; LutID: WhatToImport := ImportLUT; TextID: WhatToImport := ImportText; CustomID: WhatToImport := ImportCustom; end; SetRadioButtons1; end; if item = EditID then begin EditImportParameters; WhatToImport := ImportCustom; SetRadioButtons1; ShowParameters; SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= EightBitsID) and (item <= SixteenBitsSignedID) then begin case item of EightBitsID: ImportCustomDepth := EightBits; SixteenBitsUnsignedID: ImportCustomDepth := SixteenBitsUnsigned; SixteenBitsSignedID: ImportCustomDepth := SixteenBitsSigned; end; SetRadioButtons2; WhatToImport := ImportCustom; SetRadioButtons1; end; if item = SwapBytesID then begin ImportSwapBytes := not ImportSwapBytes; SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); WhatToImport := ImportCustom; SetRadioButtons1; end; if item = ImportAllID then begin ImportAll := not ImportAll; SetDlogItem(mylog, ImportAllID, ord(ImportAll)); end; if item = InvertID then begin ImportInvert := not ImportInvert; SetDlogItem(mylog, InvertID, ord(ImportInvert)); end; if item = CalibrateID then begin ImportCalibrate := not ImportCalibrate; SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); WhatToImport := ImportCustom; SetRadioButtons1; end; ImportDialogHook := item; end; function ImportFile (FileName: str255; RefNum: integer): boolean; const ImportDialogID = 90; var where: Point; typeList: SFTypeList; reply: SFReply; b, ImportingTIFF, HasColorMap: boolean; begin if ImportDHookProc=nil then ImportDHookProc:=NewRoutineDescriptor(@ImportDialogHook, uppDlgHookProcInfo, GetCurrentISA); ImportFile := true; DisableDensitySlice; if not macro then begin ImportAll := false; if WhatToImport=ImportMCID then WhatToImport:=ImportTIFF; end; if FileName = '' then begin where.v := 50; where.h := 50; SFPGetFile(Where, '', nil, -1, @typeList, ImportDHookProc, reply, ImportDialogID, nil); if not reply.good then begin ImportFile := false; exit(ImportFile); end; with reply do begin FileName := fname; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; end; end; if isTiffFile(FileName, RefNum) and not macro and not OptionKeyWasDown then WhatToImport := ImportTiff; ImportingTIFF := WhatToImport = ImportTiff; if ImportingTIFF then if not GetTIFFParameters(FileName, RefNum, HasColorMap) then exit(ImportFile); case WhatToImport of ImportMCID: WhatToOpen := OpenImported; ImportCustom: begin if (ImportCustomDepth <> EightBits) and (ImportCustomWidth > MaxLine) then begin PutError(concat('Maximum width of imported 16-bit images is ', long2str(MaxLine), '.')); exit(ImportFile); end; WhatToOpen := OpenCustom; end; ImportDicom: begin ImportDicomImages(FileName, RefNum, ImportAll, Import16BitFile); exit(ImportFile); end ImportLUT: begin DoImportLut(FileName, RefNum); exit(ImportFile); end; ImportText: begin ImportFile := ImportTextFile(FileName, RefNum); exit(ImportFile); end; otherwise; end; if ImportAll then ImportAllFiles(RefNum) else if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then b := Import16BitFile(FileName, RefNum) else b := OpenFile(FileName, RefNum); if macro then GenerateValues; if ImportingTIFF then WhatToImport := ImportTiff; {GetTIFFParameters may have changed it to ImportCustom.} end; procedure RevertToSaved; var fname: str255; err, f: integer; ok: boolean; size: LongInt; begin if OpPending then KillRoi; DisableDensitySlice; with Info^ do begin fname := title; SetPort(wptr); if PictureType = PICTFile then begin ok := OpenPICT(fname, vref, true); UpdatePicWindow; end else begin ShowWatch; err := fsopen(fname, vref, f); ok := true; if HeaderOffset <> -1 then ok := OpenImageHeader(f, fname, vref); if ok then begin err := SetFPos(f, fsFromStart, ImageDataOffset); size := ImageSize; CheckFileSize(f, size, ImageDataOffset); if size > 0 then err := fsread(f, size, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if Info^.InvertedImage then InvertPic; UpdatePicWindow; end; err := fsclose(f); RoiShowing := false; end; OpPending := false; Changes := false; UpdateTitleBar; end; {with} end; procedure FindWhatToPrint; var kind: integer; WhichWindow: WindowPtr; begin WhatToPrint := NothingToPrint; WhichWindow := FrontWindow; if WhichWindow = nil then exit(FindWhatToPrint); kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and info^.RoiShowing and measuring then kind := InfoKind; case kind of PicKind: if info^.RoiShowing then WhatToPrint := PrintSelection else WhatToPRint := PrintImage; HistoKind: WhatToPrint := PrintHistogram; ProfilePlotKind, CalibrationPlotKind: WhatToPrint := PrintPlot; InfoKind, ResultsKind: if mCount > 0 then WhatToPrint := PrintMeasurements; TextKind: WhatToPrint := PrintText; otherwise ; end; if (WhatToPrint = NothingToPRint) and (info <> NoInfo) then WhatToPrint := PrintImage; end; procedure UpdateFileMenu; var ShowItems, isSelection, notStack: boolean; i: integer; str, str2: str255; begin with info^ do begin ShowItems := Info <> NoInfo; isSelection := RoiShowing and (RoiType = RectRoi); notStack := StackInfo = nil; if OptionKeyWasDown and (CurrentKind <> TextKind) then begin SetMenuItemText(FileMenuH, CloseItem, 'Close All…'); SetMenuItemText(FileMenuH, SaveItem, 'Save All'); SetMenuItem(FileMenuH, CloseItem, ShowItems); end else begin SetMenuItemText(FileMenuH, CloseItem, 'Close…'); if isSelection and notStack and (CurrentKind <> TextKind) and (PictureType <> TiffFile) and (PictureType <> PictFile) and (CurrentKind = PicKind) then SetMenuItemText(FileMenuH, SaveItem, 'Save Selection') else SetMenuItemText(FileMenuH, SaveItem, 'Save'); SetMenuItem(FileMenuH, CloseItem, ShowItems or (CurrentKind = TextKind) or (CurrentKind = ResultsKind) or (CurrentKind = ProfilePlotKind) or (CurrentKind = CalibrationPlotKind) or (CurrentKind = HistoKind)); end; case CurrentKind of ProfilePlotKind, CalibrationPlotKind: ExportAsWhat := asPlotValues; HistoKind: ExportAsWhat := asHistogramValues; ResultsKind: ExportAsWhat := asMeasurements; PicKind: begin if (SaveAsWhat <> asPICT) then SaveAsWhat := asTiff; if (ExportAsWhat > asText) then ExportAsWhat := asRaw; end; otherwise end; if isSelection and notStack and (SaveAsWhat <> AsPalette) and (CurrentKind <> ResultsKind) and (CurrentKind <> TextKind) then SetMenuItemText(FileMenuH, SaveAsItem, 'Save Selection As…') else SetMenuItemText(FileMenuH, SaveAsItem, 'Save As…'); if isSelection and notStack and (ExportAsWhat <= AsText) then SetMenuItemText(FileMenuH, ExportItem, 'Export Selection As…') else SetMenuItemText(FileMenuH, ExportItem, 'Export…'); for i := SaveItem to SaveAsItem do SetMenuItem(FileMenuH, i, ShowItems or (CurrentKind = TextKind)); SetMenuItem(FileMenuH, ExportItem, (ShowItems or (CurrentKind = ResultsKind)) and (CurrentKind <> TextKind)); if isSelection then str := 'Duplicate Selection' else str := 'Duplicate'; SetMenuItemText(FileMenuH, DuplicateItem, str); for i := DuplicateItem to GetInfoItem do SetMenuItem(FileMenuH, i, ShowItems and (CurrentKind <> TextKind)); if DataType <> EightBits then str := 'Rescale' else str := 'Revert to Saved'; SetMenuItemText(FileMenuH, RevertItem, str); SetMenuItem(FileMenuH, RevertItem, (Revertable or (DataType <> EightBits)) and (CurrentKind <> TextKind)); SetMenuItem(FileMenuH, PlugInExportItem, ShowItems); FindWhatToPrint; case WhatToPrint of NothingToPrint: str := ''; PrintImage: str := 'Image'; PrintSelection: str := 'Selection'; PrintPlot: str := 'Plot'; PrintHistogram: str := 'Histogram'; PrintMeasurements: str := 'Results'; PrintText: str := 'Text'; end; SetMenuItemText(FileMenuH, PrintItem, concat('Print ', str, '…')); SetMenuItem(FileMenuH, PrintItem, WhatToPrint <> NothingToPrint); end; {with info^} end; procedure SaveAll; var SaveInfo: InfoPtr; i: integer; begin SaveInfo := Info; SaveAsWhat := AsTiff; SaveAllState := SaveAllStage1; for i := 1 to nPics do begin Info := pointer(WindowPeek(PicWindow[i])^.RefCon); SaveAs('', 0); if CommandPeriod or (SaveAllState = NoSaveAll) then leave; end; Info := SaveInfo; SaveAllState := NoSaveAll; end; function SuggestedExportName: str255; var name: str255; begin name := info^.title; case ExportAsWhat of asRaw, asMCID, asText: begin if name = 'Camera' then name := 'Untitled'; if ExportAsWhat = AsText then SuggestedExportName := concat(name, ' (Text)') else SuggestedExportName := name; end; AsLUT: SuggestedExportName := 'Palette'; asMeasurements: SuggestedExportName := concat(name, ' (Measurements)'); AsPlotValues: SuggestedExportName := concat(name, ' (Plot Values)'); asHistogramValues: SuggestedExportName := concat(name, ' (Histogram)'); asCoordinates: SuggestedExportName := concat(name, ' (Coordinates)'); end; end; function ExportHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; RawID = 9; xyCoordinatesID = 16; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDlogItem(theDialog, RawID + ord(ExportAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedExportName; if (item >= RawID) and (item <= xyCoordinatesID) then begin ExportAsWhat := ExportAsWhatType(item - RawID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedExportName); SelectdialogItemText(theDialog, EditTextID, 0, 32767); end; for i := RawID to xyCoordinatesID do SetDlogItem(theDialog, i, 0); SetDlogItem(theDialog, item, 1); end; ExportHook := item; end; procedure Export (name: str255; RefNum: integer); const CustomDialogID = 100; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; SaveAsState: SaveAsWhatType; begin if ExportDHookProc=nil then ExportDHookProc:=NewRoutineDescriptor(@ExportHook, uppDlgHookProcInfo, GetCurrentISA); with info^ do begin if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if name = '' then name := SuggestedExportName; SFPPutFile(Where, 'Save as?', name, ExportDHookProc, reply, CustomDialogID, nil); if not reply.good then begin AbortMacro; exit(Export); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if (Info = NoInfo) and (ExportAsWhat <= asText) then begin PutError('No image data available.'); AbortMacro; exit(Export); end; isSelection := RoiShowing and (RoiType = RectRoi); case ExportAsWhat of asRaw, asMCID: begin if ExportAsWhat = asMCID then InvertPic; SaveAsState := SaveAsWhat; if ExportAsWhat = AsRaw then SaveAsWhat := asRawData else SaveAsWhat := SaveAsMCID; if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); SaveAsWhat := SaveAsState; end; AsText: ExportAsText(name, RefNum); AsLUT: SaveLUT(name, RefNum); asMeasurements: if mCount > 0 then ExportMeasurements(name, RefNum) else PutError('Sorry, but no measurements are available to export.'); AsPlotValues: if PlotWindow <> nil then begin kind := WindowPeek(PlotWindow)^.WindowKind; case kind of ProfilePlotKind: ConvertPlotToText; CalibrationPlotKind: ConvertCalibrationCurveToText; otherwise TextBufSize := 0; end; SaveAsText(name, RefNum); end else beep; asHistogramValues: if HistoWindow <> nil then begin ConvertHistoToText; SaveAsText(name, RefNum); end else beep; asCoordinates: ExportCoordinates(name, RefNum); otherwise beep; end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; end. 
